home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / places.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-06-05  |  43.3 KB  |  910 lines
  1. ; CLISP - PLACES.LSP
  2. ; CLISP-spezifisch: string-concat, %rplaca, %rplacd, store, %setelt, ...
  3.  
  4. (in-package "SYSTEM")
  5. ;-------------------------------------------------------------------------------
  6. ; Funktionen zur Definition und zum Ausnutzen von places:
  7. ;-------------------------------------------------------------------------------
  8. (defun get-setf-method-multiple-value (form &optional (env nil))
  9.   (do* ((newformbackup nil newform)
  10.         (newform form (macroexpand-1 newform env)))
  11.        ((eq newformbackup newform)
  12.         (error #+DEUTSCH "Das Argument muß eine 'SETF-place' sein, ist aber keine: ~S"
  13.                #+ENGLISH "Argument ~S is not a SETF place."
  14.                #+FRANCAIS "L'argument ~S doit représenter une place modifiable."
  15.                newform
  16.        ))
  17.     (when (symbolp newform)
  18.       (let ((storevar (gensym)))
  19.         (return (values nil
  20.                         nil
  21.                         `(,storevar)
  22.                         `(SETQ ,newform ,storevar)
  23.                         `,newform
  24.     ) ) )       )
  25.     (when (and (consp newform) (symbolp (car newform)))
  26.       (let ((plist-info (get (first newform) 'SYSTEM::SETF-EXPANDER)))
  27.         (when plist-info
  28.           (if (symbolp plist-info) ; Symbol kommt von kurzem DEFSETF
  29.             (return
  30.               (do* ((storevar (gensym))
  31.                     (tempvars nil (cons (gensym) tempvars))
  32.                     (tempforms nil)
  33.                     (formr (cdr newform) (cdr formr)))
  34.                    ((atom formr)
  35.                     (setq tempforms (nreverse tempforms))
  36.                     (values tempvars
  37.                             tempforms
  38.                             `(,storevar)
  39.                             `(,plist-info ,@tempvars ,storevar)
  40.                             `(,(first newform) ,@tempvars)
  41.                    ))
  42.                 (setq tempforms (cons (car formr) tempforms))
  43.             ) )
  44.             (let ((argcount (car plist-info)))
  45.               (if (eql argcount -5)
  46.                 (return ; (-5 . fun) kommt von DEFINE-SETF-METHOD
  47.                   (funcall (cdr plist-info) newform env)
  48.                 )
  49.                 (return ; (argcount . fun) kommt von langem DEFSETF
  50.                   (let ((access-form newform)
  51.                         (tempvars '())
  52.                         (tempforms '())
  53.                         (new-access-form '()))
  54.                     (let ((i 0)) ; Argumente-Zähler
  55.                       ; argcount = -1 falls keine Keyword-Argumente existieren
  56.                       ; bzw.     = Anzahl der einzelnen Argumente vor &KEY,
  57.                       ;          = nil nachdem diese abgearbeitet sind.
  58.                       (dolist (argform (cdr access-form))
  59.                         (when (eql i argcount) (setf argcount nil i 0))
  60.                         (if (and (null argcount) (evenp i))
  61.                           (if (keywordp argform)
  62.                             (push argform new-access-form)
  63.                             (error #+DEUTSCH "Das Argument ~S zu ~S sollte ein Keyword sein."
  64.                                    #+ENGLISH "The argument ~S to ~S should be a keyword."
  65.                                    #+FRANCAIS "L'argument ~S de ~S doit être un mot-clé."
  66.                                    argform (car access-form)
  67.                           ) )
  68.                           (let ((tempvar (gensym)))
  69.                             (push tempvar tempvars)
  70.                             (push argform tempforms)
  71.                             (push tempvar new-access-form)
  72.                         ) )
  73.                         (incf i)
  74.                     ) )
  75.                     (setq new-access-form
  76.                       (cons (car access-form) (nreverse new-access-form))
  77.                     )
  78.                     (let ((newval-var (gensym)))
  79.                       (values
  80.                         (nreverse tempvars)
  81.                         (nreverse tempforms)
  82.                         (list newval-var)
  83.                         (funcall (cdr plist-info) new-access-form newval-var)
  84.                         new-access-form
  85.             ) ) ) ) ) )
  86.     ) ) ) )
  87. ) )
  88. ;-------------------------------------------------------------------------------
  89. (defun get-setf-method (form &optional (env nil))
  90.   (multiple-value-bind (vars vals stores store-form access-form)
  91.       (get-setf-method-multiple-value form env)
  92.     (unless (and (consp stores) (null (cdr stores)))
  93.       (error #+DEUTSCH "Diese 'SETF-place' produziert mehrere 'Store-Variable': ~S"
  94.              #+ENGLISH "SETF place ~S produces more than one store variable."
  95.              #+FRANCAIS "La place modifiable ~S produit plusieurs variables de résultat."
  96.              form
  97.     ) )
  98.     (values vars vals stores store-form access-form)
  99. ) )
  100. ;-------------------------------------------------------------------------------
  101. (defun documentation (symbol doctype)
  102.   (unless (symbolp symbol)
  103.     (error #+DEUTSCH "~S: Das ist als erstes Argument unzulässig, da kein Symbol: ~S"
  104.            #+ENGLISH "~S: first argument ~S is illegal, not a symbol"
  105.            #+FRANCAIS "~S : Le premier argument ~S est invalide car ce n'est pas un symbole."
  106.            'documentation symbol
  107.   ) )
  108.   (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  109. )
  110. (defun SYSTEM::%SET-DOCUMENTATION (symbol doctype value)
  111.   (unless (symbolp symbol)
  112.     (error #+DEUTSCH "~S: Das ist als erstes Argument unzulässig, da kein Symbol: ~S"
  113.            #+ENGLISH "~S: first argument ~S is illegal, not a symbol"
  114.            #+FRANCAIS "~S : Le premier argument ~S est invalide car ce n'est pas un symbole."
  115.            'documentation symbol
  116.   ) )
  117.   (if (null value)
  118.     (when (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  119.       (remf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  120.     )
  121.     (setf (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype) value)
  122. ) )
  123. ;-------------------------------------------------------------------------------
  124. (defmacro push (item place &environment env)
  125.   (if (symbolp place)
  126.     `(SETQ ,place (CONS ,item ,place))
  127.     (let ((itemvar (gensym)))
  128.       (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  129.         (do* ((SM1r SM1 (cdr SM1r))
  130.               (SM2r SM2 (cdr SM2r))
  131.               (bindlist `((,itemvar ,item)) ))
  132.              ((null SM1r)
  133.               (push `(,(first SM3) (CONS ,itemvar ,SM5)) bindlist)
  134.               `(LET* ,(nreverse bindlist)
  135.                  ,SM4
  136.              ) )
  137.           (push `(,(first SM1r) ,(first SM2r)) bindlist)
  138. ) ) ) ) )
  139. ;-------------------------------------------------------------------------------
  140. (defmacro define-setf-method (accessfn lambdalist &body body &environment env)
  141.   (unless (symbolp accessfn)
  142.     (error #+DEUTSCH "Der Name der Access-Function muß ein Symbol sein und nicht ~S."
  143.            #+ENGLISH "The name of the access function must be a symbol, not ~S"
  144.            #+FRANCAIS "Le nom de la fonction d'accès doit être un symbole et non ~S."
  145.            accessfn
  146.   ) )
  147.   (multiple-value-bind (body-rest declarations docstring)
  148.       (system::parse-body body t env)
  149.     (if (null body-rest) (setq body-rest '(NIL)))
  150.     (let ((name (make-symbol (string-concat "SETF-" (symbol-name accessfn)))))
  151.       (multiple-value-bind (newlambdalist envvar) (remove-env-arg lambdalist name)
  152.         (let ((SYSTEM::%ARG-COUNT 0)
  153.               (SYSTEM::%MIN-ARGS 0)
  154.               (SYSTEM::%RESTP nil)
  155.               (SYSTEM::%LET-LIST nil)
  156.               (SYSTEM::%KEYWORD-TESTS nil)
  157.               (SYSTEM::%DEFAULT-FORM nil)
  158.              )
  159.           (SYSTEM::ANALYZE1 newlambdalist '(CDR SYSTEM::%LAMBDA-LIST)
  160.                             name 'SYSTEM::%LAMBDA-LIST
  161.           )
  162.           (if (null newlambdalist)
  163.             (push `(IGNORE SYSTEM::%LAMBDA-LIST) declarations)
  164.           )
  165.           (let ((lengthtest (sys::make-length-test 'SYSTEM::%LAMBDA-LIST))
  166.                 (mainform
  167.                   `(LET* ,(nreverse SYSTEM::%LET-LIST)
  168.                      ,@(if declarations `(,(cons 'DECLARE declarations)))
  169.                      ,@SYSTEM::%KEYWORD-TESTS
  170.                      ,@body-rest
  171.                    )
  172.                ))
  173.             (if lengthtest
  174.               (setq mainform
  175.                 `(IF ,lengthtest
  176.                    (ERROR #+DEUTSCH "Der SETF-Expander für ~S kann nicht mit ~S Argumenten aufgerufen werden."
  177.                           #+ENGLISH "The SETF expander for ~S may not be called with ~S arguments."
  178.                           #+FRANCAIS "L'«expandeur» SETF pour ~S ne peut pas être appelé avec ~S arguments."
  179.                           (QUOTE ,accessfn) (1- (LENGTH SYSTEM::%LAMBDA-LIST))
  180.                    )
  181.                    ,mainform
  182.               )  )
  183.             )
  184.             `(EVAL-WHEN (LOAD COMPILE EVAL)
  185.                (DEFUN ,name (SYSTEM::%LAMBDA-LIST ,(or envvar 'SYSTEM::ENV))
  186.                  ,@(if envvar '() '((DECLARE (IGNORE SYSTEM::ENV))))
  187.                  ,mainform
  188.                )
  189.                (SYSTEM::%PUT ',accessfn 'SYSTEM::SETF-EXPANDER
  190.                  (CONS -5 (FUNCTION ,name))
  191.                )
  192.                (SYSTEM::%SET-DOCUMENTATION ',accessfn 'SETF ',docstring)
  193.                ',accessfn
  194.              )
  195. ) ) ) ) ) )
  196. ;-------------------------------------------------------------------------------
  197. (defmacro defsetf (accessfn &rest args &environment env)
  198.   (cond ((and (consp args) (not (listp (first args))) (symbolp (first args)))
  199.          `(EVAL-WHEN (LOAD COMPILE EVAL)
  200.             (SYSTEM::%PUT ',accessfn 'SYSTEM::SETF-EXPANDER ',(first args))
  201.             (SYSTEM::%SET-DOCUMENTATION ',accessfn 'SETF
  202.               ,(if (and (null (cddr args))
  203.                         (or (null (second args)) (stringp (second args)))
  204.                    )
  205.                  (second args)
  206.                  (if (cddr args)
  207.                    (error #+DEUTSCH "Zu viele Argumente für DEFSETF: ~S"
  208.                           #+ENGLISH "Too many arguments to DEFSETF: ~S"
  209.                           #+FRANCAIS "Trop d'arguments pour DEFSETF : ~S"
  210.                           (cdr args)
  211.                    )
  212.                    (error #+DEUTSCH "Der Dok.-String zu DEFSETF muß ein String sein: ~S"
  213.                           #+ENGLISH "The doc string to DEFSETF must be a string: ~S"
  214.                           #+FRANCAIS "La documentation pour DEFSETF doit être un chaîne : ~S"
  215.                           (second args)
  216.                ) ) )
  217.             )
  218.             ',accessfn
  219.           )
  220.         )
  221.         ((and (consp args) (listp (first args)) (consp (cdr args)) (listp (second args)))
  222.          (cond ((= (length (second args)) 1))
  223.                ((= (length (second args)) 0)
  224.                 (error #+DEUTSCH "Bei DEFSETF muß genau eine 'Store-Variable' angegeben werden."
  225.                        #+ENGLISH "Missing store variable in DEFSETF."
  226.                        #+FRANCAIS "Une variable de résultat doit être précisée dans DEFSETF."
  227.                ))
  228.                (t (cerror #+DEUTSCH "Die überzähligen Variablen werden ignoriert."
  229.                           #+ENGLISH "The excess variables will be ignored."
  230.                           #+FRANCAIS "Les variables en excès seront ignorées."
  231.                           #+DEUTSCH "Bei DEFSETF ist nur eine 'Store-Variable' erlaubt."
  232.                           #+ENGLISH "Only one store variable is allowed in DEFSETF."
  233.                           #+FRANCAIS "Une seule variable de résultat est permise dans DEFSETF."
  234.          )     )  )
  235.          (multiple-value-bind (body-rest declarations docstring)
  236.              (system::parse-body (cddr args) t env)
  237.            (let* (arg-count
  238.                   (setter
  239.                     (let* ((lambdalist (first args))
  240.                            (storevar (first (second args)))
  241.                            (SYSTEM::%ARG-COUNT 0)
  242.                            (SYSTEM::%MIN-ARGS 0)
  243.                            (SYSTEM::%RESTP nil)
  244.                            (SYSTEM::%LET-LIST nil)
  245.                            (SYSTEM::%KEYWORD-TESTS nil)
  246.                            (SYSTEM::%DEFAULT-FORM nil))
  247.                       (SYSTEM::ANALYZE1 lambdalist '(CDR SYSTEM::%ACCESS-ARGLIST)
  248.                                         accessfn 'SYSTEM::%ACCESS-ARGLIST
  249.                       )
  250.                       (setq arg-count (if (member '&KEY lambdalist) SYSTEM::%ARG-COUNT -1))
  251.                       `(LAMBDA (SYSTEM::%ACCESS-ARGLIST ,storevar)
  252.                          ,@(if (null lambdalist)
  253.                              `((DECLARE (IGNORE SYSTEM::%ACCESS-ARGLIST)))
  254.                            )
  255.                          (LET* ,(nreverse SYSTEM::%LET-LIST)
  256.                            ,@(if declarations `(,(cons 'DECLARE declarations)))
  257.                            ,@SYSTEM::%KEYWORD-TESTS
  258.                            ,@body-rest
  259.                        ) )
  260.                  )) )
  261.              `(EVAL-WHEN (LOAD COMPILE EVAL)
  262.                 (SYSTEM::%PUT ',accessfn 'SYSTEM::SETF-EXPANDER
  263.                   (CONS ,arg-count
  264.                         (FUNCTION ,(concat-pnames "SETF-" accessfn) ,setter)
  265.                 ) )
  266.                 (SYSTEM::%SET-DOCUMENTATION ',accessfn 'SETF ,docstring)
  267.                 ',accessfn
  268.               )
  269.         )) )
  270.         (t (error #+DEUTSCH "DEFSETF-Aufruf für ~S ist falsch aufgebaut."
  271.                   #+ENGLISH "Illegal syntax in DEFSETF for ~S"
  272.                   #+FRANCAIS "Le DEFSETF ~S est mal formé."
  273.                   accessfn
  274. ) )     )  )
  275. ;-------------------------------------------------------------------------------
  276. (defmacro pop (place &environment env)
  277.   (if (symbolp place)
  278.     `(PROG1 (CAR ,place) (SETQ ,place (CDR ,place)))
  279.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  280.       (do* ((SM1r SM1 (cdr SM1r))
  281.             (SM2r SM2 (cdr SM2r))
  282.             (bindlist nil))
  283.            ((null SM1r)
  284.             (push `(,(first SM3) ,SM5) bindlist)
  285.             `(LET* ,(nreverse bindlist)
  286.                (PROG1
  287.                  (CAR ,(first SM3))
  288.                  (SETQ ,(first SM3) (CDR ,(first SM3)))
  289.                  ,SM4
  290.              ) )
  291.            )
  292.         (push `(,(first SM1r) ,(first SM2r)) bindlist)
  293. ) ) ) )
  294. ;-------------------------------------------------------------------------------
  295. (defmacro psetf (&whole form &rest args &environment env)
  296.   (do ((arglist args (cddr arglist))
  297.        (bindlist nil)
  298.        (storelist nil))
  299.       ((atom arglist)
  300.        `(LET* ,(nreverse bindlist)
  301.           ,@storelist
  302.           NIL
  303.       ) )
  304.     (when (atom (cdr arglist))
  305.       (error #+DEUTSCH "~S mit einer ungeraden Zahl von Argumenten aufgerufen: ~S"
  306.              #+ENGLISH "~S called with an odd number of arguments: ~S"
  307.              #+FRANCAIS "~S fut appelé avec un nombre impair d'arguments : ~S"
  308.              'psetf form
  309.     ) )
  310.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method (first arglist) env)
  311.       (declare (ignore SM5))
  312.       (do* ((SM1r SM1 (cdr SM1r))
  313.             (SM2r SM2 (cdr SM2r)))
  314.            ((null SM1r))
  315.         (push `(,(first SM1r) ,(first SM2r)) bindlist)
  316.       )
  317.       (push `(,(first SM3) ,(second arglist)) bindlist)
  318.       (push SM4 storelist)
  319. ) ) )
  320. ;-------------------------------------------------------------------------------
  321. (defmacro pushnew (item place &rest keylist &environment env)
  322.   (if (symbolp place)
  323.     `(SETQ ,place (ADJOIN ,item ,place ,@keylist))
  324.     (let ((itemvar (gensym)))
  325.       (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  326.         (do* ((SM1r SM1 (cdr SM1r))
  327.               (SM2r SM2 (cdr SM2r))
  328.               (bindlist `((,itemvar ,item)) ))
  329.              ((null SM1r)
  330.               (push `(,(first SM3) (ADJOIN ,itemvar ,SM5 ,@keylist)) bindlist)
  331.               `(LET* ,(nreverse bindlist)
  332.                  ,SM4
  333.              ) )
  334.           (push `(,(first SM1r) ,(first SM2r)) bindlist)
  335. ) ) ) ) )
  336. ;-------------------------------------------------------------------------------
  337. (defmacro remf (place indicator &environment env)
  338.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  339.     (do* ((SM1r SM1 (cdr SM1r))
  340.           (SM2r SM2 (cdr SM2r))
  341.           (bindlist nil)
  342.           (indicatorvar (gensym))
  343.           (var1 (gensym))
  344.           (var2 (gensym)))
  345.          ((null SM1r)
  346.           (push `(,(first SM3) ,SM5) bindlist)
  347.           (push `(,indicatorvar ,indicator) bindlist)
  348.           `(LET* ,(nreverse bindlist)
  349.              (DO ((,var1 ,(first SM3) (CDDR ,var1))
  350.                   (,var2 NIL ,var1))
  351.                  ((ATOM ,var1) NIL)
  352.                (COND ((ATOM (CDR ,var1))
  353.                       (ERROR #+DEUTSCH "REMF: Property-Liste ungerader Länge aufgetreten."
  354.                              #+ENGLISH "REMF: property list with an odd length"
  355.                              #+FRANCAIS "REMF : Occurence d'une liste de propriétés de longueur impaire."
  356.                      ))
  357.                      ((EQ (CAR ,var1) ,indicatorvar)
  358.                       (IF ,var2
  359.                         (RPLACD (CDR ,var2) (CDDR ,var1))
  360.                         (PROGN (SETQ ,(first SM3) (CDDR ,(first SM3))) ,SM4)
  361.                       )
  362.                       (RETURN T)
  363.            ) ) )     )
  364.          )
  365.       (push `(,(first SM1r) ,(first SM2r)) bindlist)
  366. ) ) )
  367. ;-------------------------------------------------------------------------------
  368. (defmacro rotatef (&rest args &environment env)
  369.   (cond ((null args) NIL)
  370.         ((null (cdr args)) `(PROGN ,(car args) NIL) )
  371.         (t (do* ((arglist args (cdr arglist))
  372.                  (bindlist nil)
  373.                  (storelist nil)
  374.                  (lastvar nil)
  375.                  (firstbind nil))
  376.                 ((atom arglist)
  377.                  (setf (car firstbind) lastvar)
  378.                  `(LET* ,(nreverse bindlist) ,@(nreverse storelist) NIL)
  379.                 )
  380.              (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  381.                  (get-setf-method (first arglist) env)
  382.                (do* ((SM1r SM1 (cdr SM1r))
  383.                      (SM2r SM2 (cdr SM2r)))
  384.                     ((null SM1r))
  385.                  (push `(,(first SM1r) ,(first SM2r)) bindlist)
  386.                )
  387.                (push `(,lastvar ,SM5) bindlist)
  388.                (if (null firstbind) (setq firstbind (first bindlist)))
  389.                (push SM4 storelist)
  390.                (setq lastvar (first SM3))
  391. ) )     )  ) )
  392. ;-------------------------------------------------------------------------------
  393. (defmacro define-modify-macro (name lambdalist function &optional docstring)
  394.   (let* ((varlist nil)
  395.          (restvar nil))
  396.     (do* ((lambdalistr lambdalist (cdr lambdalistr))
  397.           (next))
  398.          ((null lambdalistr))
  399.       (setq next (first lambdalistr))
  400.       (cond ((eq next '&OPTIONAL))
  401.             ((eq next '&REST)
  402.              (if (symbolp (second lambdalistr))
  403.                (setq restvar (second lambdalistr))
  404.                (error #+DEUTSCH "In der Definition von ~S ist die &REST-Variable kein Symbol: ~S"
  405.                       #+ENGLISH "In the definition of ~S: &REST variable ~S should be a symbol."
  406.                       #+FRANCAIS "Dans la définition de ~S la variable pour &REST n'est pas un symbole : ~S."
  407.                       name (second lambdalistr)
  408.              ) )
  409.              (if (null (cddr lambdalistr))
  410.                (return)
  411.                (error #+DEUTSCH "Nach &REST ist nur eine Variable erlaubt; es kam: ~S"
  412.                       #+ENGLISH "Only one variable is allowed after &REST, not ~S"
  413.                       #+FRANCAIS "Une seule variable est permise pour &REST et non ~S."
  414.                       lambdalistr
  415.             )) )
  416.             ((or (eq next '&KEY) (eq next '&ALLOW-OTHER-KEYS) (eq next '&AUX))
  417.              (error #+DEUTSCH "In einer DEFINE-MODIFY-MACRO-Lambdaliste ist ~S unzulässig."
  418.                     #+ENGLISH "Illegal in a DEFINE-MODIFY-MACRO lambda list: ~S"
  419.                     #+FRANCAIS "~S n'est pas permis dans une liste lambda pour DEFINE-MODIFY-MACRO."
  420.                     next
  421.             ))
  422.             ((symbolp next) (push next varlist))
  423.             ((and (listp next) (symbolp (first next)))
  424.              (push (first next) varlist)
  425.             )
  426.             (t (error #+DEUTSCH "Lambdalisten dürfen nur Symbole und Listen enthalten, nicht aber ~S"
  427.                       #+ENGLISH "lambda list may only contain symbols and lists, not ~S"
  428.                       #+FRANCAIS "Les listes lambda ne peuvent contenir que des symboles et des listes et non ~S."
  429.                       next
  430.             )  )
  431.     ) )
  432.     (setq varlist (nreverse varlist))
  433.     `(DEFMACRO ,name (%REFERENCE ,@lambdalist &ENVIRONMENT ENV) ,docstring
  434.        (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
  435.            (GET-SETF-METHOD %REFERENCE ENV)
  436.          (DO ((D DUMMIES (CDR D))
  437.               (V VALS (CDR V))
  438.               (LET-LIST NIL (CONS (LIST (CAR D) (CAR V)) LET-LIST)))
  439.              ((NULL D)
  440.               (WHEN (SYMBOLP GETTER)
  441.                 (RETURN
  442.                   (SUBST
  443.                     (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)
  444.                     (CAR NEWVAL)
  445.                     SETTER
  446.               ) ) )
  447.               (PUSH
  448.                 (LIST
  449.                   (CAR NEWVAL)
  450.                   (IF (AND (LISTP %REFERENCE) (EQ (CAR %REFERENCE) 'THE))
  451.                     (LIST 'THE (CADR %REFERENCE)
  452.                       (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)
  453.                     )
  454.                     (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar)
  455.                 ) )
  456.                 LET-LIST
  457.               )
  458.               (LIST 'LET* (NREVERSE LET-LIST) SETTER)
  459.      ) ) ) )
  460. ) )
  461. ;-------------------------------------------------------------------------------
  462. (define-modify-macro decf (&optional (delta 1)) -)
  463. ;-------------------------------------------------------------------------------
  464. (define-modify-macro incf (&optional (delta 1)) +)
  465. ;-------------------------------------------------------------------------------
  466. (defmacro setf (&whole form &rest args &environment env)
  467.   (let ((dummy (length args)))
  468.     (cond ((= dummy 2)
  469.            (let* ((place (first args))
  470.                   (value (second args)))
  471.              (do* ((oldplaceform nil newplaceform)
  472.                    (newplaceform place (macroexpand-1 newplaceform env)))
  473.                   ((eq newplaceform oldplaceform)
  474.                    (error #+DEUTSCH "Das ist keine erlaubte 'SETF-Place' : ~S"
  475.                           #+ENGLISH "Illegal SETF place: ~S"
  476.                           #+FRANCAIS "Ceci n'est pas une place modifiable valide : ~S"
  477.                           place
  478.                   ))
  479.                (cond ((atom newplaceform)
  480.                       (return `(SETQ ,newplaceform ,value))
  481.                      )
  482.                      ((and (setq dummy
  483.                              (get (first newplaceform) 'SYSTEM::SETF-EXPANDER)
  484.                            )
  485.                            (symbolp dummy)
  486.                       )
  487.                       (return `(,dummy ,@(cdr newplaceform) ,value))
  488.                      )
  489.                      ((and (eq (first newplaceform) 'THE)
  490.                            (eql (length newplaceform) 3)
  491.                       )
  492.                       (return `(SETF ,(third newplaceform)
  493.                                      (THE ,(second newplaceform) ,value)
  494.                      ))        )
  495.                      ((and (eq (first newplaceform) 'VALUES-LIST)
  496.                            (eql (length newplaceform) 2)
  497.                       )
  498.                       (return `(VALUES-LIST
  499.                                  (SETF ,(second newplaceform)
  500.                                        (MULTIPLE-VALUE-LIST ,value)
  501.                      ))        ) )
  502.                      (dummy
  503.                        (return
  504.                          (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  505.                              (get-setf-method-multiple-value newplaceform env)
  506.                            (declare (ignore SM5))
  507.                            (do* ((SM1r SM1 (cdr SM1r))
  508.                                  (SM2r SM2 (cdr SM2r))
  509.                                  (bindlist nil))
  510.                                 ((null SM1r)
  511.                                  (if (eql (length SM3) 1) ; eine Store-Variable
  512.                                    `(LET* ,(nreverse
  513.                                              (cons `(,(first SM3) ,value)
  514.                                                    bindlist
  515.                                            ) )
  516.                                       ,SM4
  517.                                     )
  518.                                    ; mehrere Store-Variable
  519.                                    (if
  520.                                      ; Hat SM4 die Gestalt
  521.                                      ; (VALUES (SETQ v1 store1) ...) ?
  522.                                      (and (consp SM4) (eq (car SM4) 'VALUES)
  523.                                        (do ((SM3r SM3 (cdr SM3r))
  524.                                             (SM4r (cdr SM4) (cdr SM4r)))
  525.                                            ((or (null SM3r) (null SM4r))
  526.                                             (and (null SM3r) (null SM4r))
  527.                                            )
  528.                                          (unless (and (consp (car SM4r))
  529.                                                       (eq (caar SM4r) 'SETQ)
  530.                                                       (symbolp (cadar SM4r))
  531.                                                       (eq (caddar SM4r) (car SM3r))
  532.                                                  )
  533.                                            (return nil)
  534.                                      ) ) )
  535.                                      (let ((vlist (mapcar #'second (rest SM4))))
  536.                                        `(LET* ,(nreverse bindlist)
  537.                                           (MULTIPLE-VALUE-SETQ ,vlist ,value)
  538.                                           (VALUES ,@vlist)
  539.                                      )  )
  540.                                      `(LET* ,(nreverse bindlist)
  541.                                         (MULTIPLE-VALUE-BIND ,SM3 ,value
  542.                                           ,SM4
  543.                                       ) )
  544.                                 )) )
  545.                              (push `(,(first SM1r) ,(first SM2r)) bindlist)
  546.           )) ) )     ) ) ) )
  547.           ((oddp dummy)
  548.            (error #+DEUTSCH "~S mit einer ungeraden Zahl von Argumenten aufgerufen: ~S"
  549.                   #+ENGLISH "~S called with an odd number of arguments: ~S"
  550.                   #+FRANCAIS "~S fut appelé avec un nombre impair d'arguments : ~S"
  551.                   'setf form
  552.           ))
  553.           (t (do* ((arglist args (cddr arglist))
  554.                    (L nil))
  555.                   ((null arglist) `(PROGN ,@(nreverse L)))
  556.                (push `(SETF ,(first arglist) ,(second arglist)) L)
  557.           )  )
  558. ) ) )
  559. ;-------------------------------------------------------------------------------
  560. (defmacro shiftf (&whole form &rest args &environment env)
  561.   (when (< (length args) 2)
  562.     (error #+DEUTSCH "SHIFTF mit zu wenig Argumenten aufgerufen: ~S"
  563.            #+ENGLISH "SHIFTF called with too few arguments: ~S"
  564.            #+FRANCAIS "SHIFTF fut appelé avec trop peu d'arguments : ~S"
  565.            form
  566.   ) )
  567.   (do* ((resultvar (gensym))
  568.         (arglist args (cdr arglist))
  569.         (bindlist nil)
  570.         (storelist nil)
  571.         (lastvar resultvar))
  572.        ((atom (cdr arglist))
  573.         (push `(,lastvar ,(first arglist)) bindlist)
  574.         `(LET* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar)
  575.        )
  576.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method (first arglist) env)
  577.       (do* ((SM1r SM1 (cdr SM1r))
  578.             (SM2r SM2 (cdr SM2r)))
  579.            ((null Sm1r))
  580.         (push `(,(first SM1r) ,(first SM2r)) bindlist)
  581.       )
  582.       (push `(,lastvar ,SM5) bindlist)
  583.       (push SM4 storelist)
  584.       (setq lastvar (first SM3))
  585. ) ) )
  586. ;-------------------------------------------------------------------------------
  587. ; Definition von places:
  588. ;-------------------------------------------------------------------------------
  589. (defsetf aref (array &rest indices) (value)
  590.   `(SYSTEM::STORE ,array ,@indices ,value)
  591. )
  592. ;-------------------------------------------------------------------------------
  593. (defun SYSTEM::%SETNTH (index list value)
  594.   (let ((pointer (nthcdr index list)))
  595.     (if (null pointer)
  596.       (error #+DEUTSCH "(SETF (NTH ...) ...) : Index ~S ist zu groß für ~S."
  597.              #+ENGLISH "(SETF (NTH ...) ...) : index ~S is too large for ~S"
  598.              #+FRANCAIS "(SETF (NTH ...) ...) : L'index ~S est trop grand pour ~S."
  599.              index list
  600.       )
  601.       (rplaca pointer value)
  602.     )
  603.     value
  604. ) )
  605. (defsetf nth SYSTEM::%SETNTH)
  606. ;-------------------------------------------------------------------------------
  607. (defsetf elt SYSTEM::%SETELT)
  608. ;-------------------------------------------------------------------------------
  609. (defsetf rest SYSTEM::%RPLACD)
  610. (defsetf first SYSTEM::%RPLACA)
  611. (defsetf second (list) (value) `(SYSTEM::%RPLACA (CDR ,list) ,value))
  612. (defsetf third (list) (value) `(SYSTEM::%RPLACA (CDDR ,list) ,value))
  613. (defsetf fourth (list) (value) `(SYSTEM::%RPLACA (CDDDR ,list) ,value))
  614. (defsetf fifth (list) (value) `(SYSTEM::%RPLACA (CDDDDR ,list) ,value))
  615. (defsetf sixth (list) (value) `(SYSTEM::%RPLACA (CDR (CDDDDR ,list)) ,value))
  616. (defsetf seventh (list) (value) `(SYSTEM::%RPLACA (CDDR (CDDDDR ,list)) ,value))
  617. (defsetf eighth (list) (value) `(SYSTEM::%RPLACA (CDDDR (CDDDDR ,list)) ,value))
  618. (defsetf ninth (list) (value) `(SYSTEM::%RPLACA (CDDDDR (CDDDDR ,list)) ,value))
  619. (defsetf tenth (list) (value) `(SYSTEM::%RPLACA (CDR (CDDDDR (CDDDDR ,list))) ,value))
  620.  
  621. (defsetf car SYSTEM::%RPLACA)
  622. (defsetf cdr SYSTEM::%RPLACD)
  623. (defsetf caar (list) (value) `(SYSTEM::%RPLACA (CAR ,list) ,value))
  624. (defsetf cadr (list) (value) `(SYSTEM::%RPLACA (CDR ,list) ,value))
  625. (defsetf cdar (list) (value) `(SYSTEM::%RPLACD (CAR ,list) ,value))
  626. (defsetf cddr (list) (value) `(SYSTEM::%RPLACD (CDR ,list) ,value))
  627. (defsetf caaar (list) (value) `(SYSTEM::%RPLACA (CAAR ,list) ,value))
  628. (defsetf caadr (list) (value) `(SYSTEM::%RPLACA (CADR ,list) ,value))
  629. (defsetf cadar (list) (value) `(SYSTEM::%RPLACA (CDAR ,list) ,value))
  630. (defsetf caddr (list) (value) `(SYSTEM::%RPLACA (CDDR ,list) ,value))
  631. (defsetf cdaar (list) (value) `(SYSTEM::%RPLACD (CAAR ,list) ,value))
  632. (defsetf cdadr (list) (value) `(SYSTEM::%RPLACD (CADR ,list) ,value))
  633. (defsetf cddar (list) (value) `(SYSTEM::%RPLACD (CDAR ,list) ,value))
  634. (defsetf cdddr (list) (value) `(SYSTEM::%RPLACD (CDDR ,list) ,value))
  635. (defsetf caaaar (list) (value) `(SYSTEM::%RPLACA (CAAAR ,list) ,value))
  636. (defsetf caaadr (list) (value) `(SYSTEM::%RPLACA (CAADR ,list) ,value))
  637. (defsetf caadar (list) (value) `(SYSTEM::%RPLACA (CADAR ,list) ,value))
  638. (defsetf caaddr (list) (value) `(SYSTEM::%RPLACA (CADDR ,list) ,value))
  639. (defsetf cadaar (list) (value) `(SYSTEM::%RPLACA (CDAAR ,list) ,value))
  640. (defsetf cadadr (list) (value) `(SYSTEM::%RPLACA (CDADR ,list) ,value))
  641. (defsetf caddar (list) (value) `(SYSTEM::%RPLACA (CDDAR ,list) ,value))
  642. (defsetf cadddr (list) (value) `(SYSTEM::%RPLACA (CDDDR ,list) ,value))
  643. (defsetf cdaaar (list) (value) `(SYSTEM::%RPLACD (CAAAR ,list) ,value))
  644. (defsetf cdaadr (list) (value) `(SYSTEM::%RPLACD (CAADR ,list) ,value))
  645. (defsetf cdadar (list) (value) `(SYSTEM::%RPLACD (CADAR ,list) ,value))
  646. (defsetf cdaddr (list) (value) `(SYSTEM::%RPLACD (CADDR ,list) ,value))
  647. (defsetf cddaar (list) (value) `(SYSTEM::%RPLACD (CDAAR ,list) ,value))
  648. (defsetf cddadr (list) (value) `(SYSTEM::%RPLACD (CDADR ,list) ,value))
  649. (defsetf cdddar (list) (value) `(SYSTEM::%RPLACD (CDDAR ,list) ,value))
  650. (defsetf cddddr (list) (value) `(SYSTEM::%RPLACD (CDDDR ,list) ,value))
  651. ;-------------------------------------------------------------------------------
  652. (defsetf svref SYSTEM::SVSTORE)
  653. ;-------------------------------------------------------------------------------
  654. (defsetf GET (symbol indicator &optional default) (value)
  655.   (let ((storeform `(SYSTEM::%PUT ,symbol ,indicator ,value)))
  656.     (if default
  657.       `(PROGN ,default ,storeform) ; default wird nur zum Schein ausgewertet
  658.       `,storeform
  659. ) ) )
  660. ;-------------------------------------------------------------------------------
  661. ; Schreibt zu einem bestimmten Indicator einen Wert in eine gegebene
  662. ; Propertyliste. Wert ist NIL falls erfolgreich getan oder die neue
  663. ; (erweiterte) Propertyliste.
  664. (defun sys::%putf (plist indicator value)
  665.   (do ((plistr plist (cddr plistr)))
  666.       ((atom plistr) (list* indicator value plist))
  667.     (when (atom (cdr plistr))
  668.       (error #+DEUTSCH "(SETF (GETF ...) ...) : Property-Liste ungerader Länge aufgetaucht."
  669.              #+ENGLISH "(SETF (GETF ...) ...) : property list with an odd length"
  670.              #+FRANCAIS "(SETF (GETF ...) ...) : Occurence d'une liste de propriétés de longueur impaire."
  671.     ))
  672.     (when (eq (car plistr) indicator)
  673.       (rplaca (cdr plistr) value)
  674.       (return nil)
  675. ) ) )
  676. (define-setf-method getf (place indicator &optional default &environment env)
  677.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  678.     (let* ((storevar (gensym))
  679.            (indicatorvar (gensym))
  680.            (defaultvar-list (if default (list (gensym)) `()))
  681.           )
  682.       (values
  683.         `(,@SM1 ,indicatorvar ,@defaultvar-list)
  684.         `(,@SM2 ,indicator    ,@(if default `(,default) `()))
  685.         `(,storevar)
  686.         `(LET ((,(first SM3) (SYS::%PUTF ,SM5 ,indicatorvar ,storevar)))
  687.            ,@defaultvar-list ; defaultvar zum Schein auswerten
  688.            (WHEN ,(first SM3) ,SM4)
  689.            ,storevar
  690.          )
  691.         `(GETF ,SM5 ,indicatorvar ,@defaultvar-list)
  692. ) ) ) )
  693. ;-------------------------------------------------------------------------------
  694. (defsetf GETHASH (key hashtable &optional default) (value)
  695.   (let ((storeform `(SYSTEM::PUTHASH ,key ,hashtable ,value)))
  696.     (if default
  697.       `(PROGN ,default ,storeform) ; default wird nur zum Schein ausgewertet
  698.       `,storeform
  699. ) ) )
  700. ;-------------------------------------------------------------------------------
  701. #| ; siehe oben:
  702. (defun SYSTEM::%SET-DOCUMENTATION (symbol doctype value)
  703.   (unless (symbolp symbol)
  704.     (error #+DEUTSCH "Das ist als erstes Argument unzulässig, da kein Symbol: ~S"
  705.            #+ENGLISH "first argument ~S is illegal, not a symbol"
  706.            #+FRANCAIS "Le premier argument ~S est invalide car ce n'est pas un symbole."
  707.            symbol
  708.   ) )
  709.   (if (null value)
  710.     (remf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype)
  711.     (setf (getf (get symbol 'SYSTEM::DOCUMENTATION-STRINGS) doctype) value)
  712. ) )
  713. |#
  714. (defsetf documentation SYSTEM::%SET-DOCUMENTATION)
  715. ;-------------------------------------------------------------------------------
  716. (defsetf fill-pointer SYSTEM::SET-FILL-POINTER)
  717. ;-------------------------------------------------------------------------------
  718. (defsetf SYMBOL-VALUE SET)
  719. ;-------------------------------------------------------------------------------
  720. (defsetf SYMBOL-FUNCTION SYSTEM::%PUTD)
  721. ;-------------------------------------------------------------------------------
  722. (defsetf SYMBOL-PLIST SYSTEM::%PUTPLIST)
  723. ;-------------------------------------------------------------------------------
  724. (defsetf MACRO-FUNCTION (symbol) (value)
  725.   `(PROGN
  726.      (SETF (SYMBOL-FUNCTION ,symbol) (CONS 'SYSTEM::MACRO ,value))
  727.      (REMPROP ,symbol 'SYSTEM::MACRO)
  728.      ,value
  729.    )
  730. )
  731. ;-------------------------------------------------------------------------------
  732. (defsetf CHAR SYSTEM::STORE-CHAR)
  733. (defsetf SCHAR SYSTEM::STORE-SCHAR)
  734. (defsetf BIT SYSTEM::STORE)
  735. (defsetf SBIT SYSTEM::STORE)
  736. (defsetf SUBSEQ (sequence start &optional end) (value)
  737.   `(PROGN (REPLACE ,sequence ,value :START1 ,start :END1 ,end) ,value)
  738. )
  739. ;-------------------------------------------------------------------------------
  740. (define-setf-method char-bit (char name &environment env)
  741.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method char env)
  742.     (let* ((namevar (gensym))
  743.            (storevar (gensym)))
  744.       (values `(,@SM1 ,namevar)
  745.               `(,@SM2 ,name)
  746.               `(,storevar)
  747.               `(LET ((,(first SM3) (SET-CHAR-BIT ,SM5 ,namevar ,storevar)))
  748.                  ,SM4
  749.                  ,storevar
  750.                )
  751.               `(CHAR-BIT ,SM5 ,namevar)
  752. ) ) ) )
  753. ;-------------------------------------------------------------------------------
  754. (define-setf-method LDB (bytespec integer &environment env)
  755.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method integer env)
  756.     (let* ((bytespecvar (gensym))
  757.            (storevar (gensym)))
  758.       (values (cons bytespecvar SM1)
  759.               (cons bytespec SM2)
  760.               `(,storevar)
  761.               `(LET ((,(first SM3) (DPB ,storevar ,bytespecvar ,SM5)))
  762.                  ,SM4
  763.                  ,storevar
  764.                )
  765.               `(LDB ,bytespecvar ,SM5)
  766. ) ) ) )
  767. ;-------------------------------------------------------------------------------
  768. (define-setf-method MASK-FIELD (bytespec integer &environment env)
  769.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method integer env)
  770.     (let* ((bytespecvar (gensym))
  771.            (storevar (gensym)))
  772.       (values (cons bytespecvar SM1)
  773.               (cons bytespec SM2)
  774.               `(,storevar)
  775.               `(LET ((,(first SM3) (DEPOSIT-FIELD ,storevar ,bytespecvar ,SM5)))
  776.                  ,SM4
  777.                  ,storevar
  778.                )
  779.               `(MASK-FIELD ,bytespecvar ,SM5)
  780. ) ) ) )
  781. ;-------------------------------------------------------------------------------
  782. (define-setf-method THE (type place &environment env)
  783.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place env)
  784.     (values SM1 SM2 SM3
  785.             (subst `(THE ,type ,(first SM3)) (first SM3) SM4)
  786.             `(THE ,type ,SM5)
  787. ) ) )
  788. ;-------------------------------------------------------------------------------
  789. (define-setf-method APPLY (fun &rest args &environment env)
  790.   (if (and (listp fun)
  791.            (eq (list-length fun) 2)
  792.            (eq (first fun) 'FUNCTION)
  793.            (symbolp (second fun))
  794.       )
  795.     (setq fun (second fun))
  796.     (error #+DEUTSCH "SETF von APPLY ist nur für Funktionen der Form #'symbol als Argument definiert."
  797.            #+ENGLISH "SETF APPLY is only defined for functions of the form #'symbol."
  798.            #+FRANCAIS "Un SETF de APPLY n'est défini que pour les fonctions de la forme #'symbole."
  799.   ) )
  800.   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method (cons fun args) env)
  801.     (unless (eq (car (last args)) (car (last SM2)))
  802.       (error #+DEUTSCH "APPLY von ~S kann nicht als 'SETF-Place' aufgefaßt werden."
  803.              #+ENGLISH "APPLY on ~S is not a SETF place."
  804.              #+FRANCAIS "APPLY de ~S ne peux pas être considéré comme une place modifiable."
  805.              fun
  806.     ) )
  807.     (let ((item (car (last SM1)))) ; 'item' steht für eine Argumentliste!
  808.       (labels ((splice (arglist)
  809.                  ; Würde man in (LIST . arglist) das 'item' nicht als 1 Element,
  810.                  ; sondern gespliced, sozusagen als ',@item', haben wollen, so
  811.                  ; bräuchte man die Form, die (splice arglist) liefert.
  812.                  (if (endp arglist)
  813.                    'NIL
  814.                    (let ((rest (splice (cdr arglist))))
  815.                      (if (eql (car arglist) item)
  816.                        ; ein (APPEND item ...) davorhängen, wie bei Backquote
  817.                        (backquote-append item rest)
  818.                        ; ein (CONS (car arglist) ...) davorhängen, wie bei Backquote
  819.                        (backquote-cons (car arglist) rest)
  820.               )) ) ) )
  821.         (flet ((call-splicing (form)
  822.                  ; ersetzt einen Funktionsaufruf form durch einen, bei dem
  823.                  ; 'item' nicht 1 Argument, sondern eine Argumentliste liefert
  824.                  (let ((fun (first form))
  825.                        (argform (splice (rest form))))
  826.                    ; (APPLY #'fun argform) vereinfachen:
  827.                    ; (APPLY #'fun NIL) --> (fun)
  828.                    ; (APPLY #'fun (LIST ...)) --> (fun ...)
  829.                    ; (APPLY #'fun (CONS x y)) --> (APPLY #'fun x y)
  830.                    ; (APPLY #'fun (LIST* ... z)) --> (APPLY #'fun ... z)
  831.                    (if (or (null argform)
  832.                            (and (consp argform) (eq (car argform) 'LIST))
  833.                        )
  834.                      (cons fun (cdr argform))
  835.                      (list* 'APPLY
  836.                             (list 'FUNCTION fun)
  837.                             (if (and (consp argform)
  838.                                      (or (eq (car argform) 'LIST*)
  839.                                          (eq (car argform) 'CONS)
  840.                                 )    )
  841.                               (cdr argform)
  842.                               (list argform)
  843.               )) ) ) )      )
  844.           (values SM1 SM2 SM3 (call-splicing SM4) (call-splicing SM5))
  845. ) ) ) ) )
  846. ;-------------------------------------------------------------------------------
  847. ; Zusätzliche Definitionen von places
  848. ;-------------------------------------------------------------------------------
  849. (define-setf-method funcall (fun &rest args &environment env)
  850.   (unless (and (listp fun)
  851.                (eq (list-length fun) 2)
  852.                (let ((fun1 (first fun)))
  853.                  (or (eq fun1 'FUNCTION) (eq fun1 'QUOTE))
  854.                )
  855.                (symbolp (second fun))
  856.                (setq fun (second fun))
  857.           )
  858.     (error #+DEUTSCH "SETF von FUNCALL ist nur für Funktionen der Form #'symbol definiert."
  859.            #+ENGLISH "SETF FUNCALL is only defined for functions of the form #'symbol."
  860.            #+FRANCAIS "Un SETF de FUNCALL n'est défini que pour les fonctions de la forme #'symbole."
  861.   ) )
  862.   (get-setf-method (cons fun args) env)
  863. )
  864. ;-------------------------------------------------------------------------------
  865. (defsetf GET-DISPATCH-MACRO-CHARACTER
  866.          (disp-char sub-char &optional (readtable '*READTABLE*)) (value)
  867.   `(PROGN (SET-DISPATCH-MACRO-CHARACTER ,disp-char ,sub-char ,value ,readtable) ,value)
  868. )
  869. ;-------------------------------------------------------------------------------
  870. (defsetf long-float-digits SYSTEM::%SET-LONG-FLOAT-DIGITS)
  871. ;-------------------------------------------------------------------------------
  872. (defsetf DEFAULT-DIRECTORY () (value)
  873.   `(PROGN (CD ,value) ,value)
  874. )
  875. ;-------------------------------------------------------------------------------
  876. ; Handhabung von (SETF (VALUES place1 ... placek) form)
  877. ; --> (MULTIPLE-VALUE-BIND (dummy1 ... dummyk) form
  878. ;       (SETF place1 dummy1 ... placek dummyk)
  879. ;       (VALUES dummy1 ... dummyk)
  880. ;     )
  881. (define-setf-method VALUES (&rest subplaces &environment env)
  882.   (do ((temps nil)
  883.        (vals nil)
  884.        (stores nil)
  885.        (storeforms nil)
  886.        (accessforms nil)
  887.        (subplacesr subplaces))
  888.       ((atom subplacesr)
  889.        (setq temps (nreverse temps))
  890.        (setq vals (nreverse vals))
  891.        (setq stores (nreverse stores))
  892.        (setq storeforms (nreverse storeforms))
  893.        (setq accessforms (nreverse accessforms))
  894.        (values temps
  895.                vals
  896.                stores
  897.                `(VALUES ,@storeforms)
  898.                `(VALUES ,@accessforms)
  899.       ))
  900.     (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  901.         (get-setf-method (pop subplacesr) env)
  902.       (setq temps (revappend SM1 temps))
  903.       (setq vals (revappend SM2 vals))
  904.       (setq stores (revappend SM3 stores))
  905.       (setq storeforms (cons SM4 storeforms))
  906.       (setq accessforms (cons SM5 accessforms))
  907. ) ) )
  908. ;-------------------------------------------------------------------------------
  909.  
  910.